home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol146 / xlsys.c < prev   
Encoding:
C/C++ Source or Header  |  1986-12-16  |  3.3 KB  |  152 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *xlstack,*xlenv;
  10. extern int anodes;
  11.  
  12. /* external symbols */
  13. extern NODE *a_subr,*a_fsubr;
  14. extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr;
  15. extern NODE *true;
  16.  
  17. /* xload - direct input from a file */
  18. NODE *xload(args)
  19.   NODE *args;
  20. {
  21.     NODE *oldstk,fname,*val;
  22.     int vflag,pflag;
  23.  
  24.     /* create a new stack frame */
  25.     oldstk = xlsave(&fname,NULL);
  26.  
  27.     /* get the file name, verbose flag and print flag */
  28.     fname.n_ptr = xlmatch(STR,&args);
  29.     vflag = (args ? xlarg(&args) != NIL : TRUE);
  30.     pflag = (args ? xlarg(&args) != NIL : FALSE);
  31.     xllastarg(args);
  32.  
  33.     /* load the file */
  34.     val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);
  35.  
  36.     /* restore the previous stack frame */
  37.     xlstack = oldstk;
  38.  
  39.     /* return the status */
  40.     return (val);
  41. }
  42.  
  43. /* xgc - xlisp function to force garbage collection */
  44. NODE *xgc(args)
  45.   NODE *args;
  46. {
  47.     /* make sure there aren't any arguments */
  48.     xllastarg(args);
  49.  
  50.     /* garbage collect */
  51.     gc();
  52.  
  53.     /* return nil */
  54.     return (NIL);
  55. }
  56.  
  57. /* xexpand - xlisp function to force memory expansion */
  58. NODE *xexpand(args)
  59.   NODE *args;
  60. {
  61.     int n,i;
  62.  
  63.     /* get the new number to allocate */
  64.     n = (args ? xlmatch(INT,&args)->n_int : 1);
  65.     xllastarg(args);
  66.  
  67.     /* allocate more segments */
  68.     for (i = 0; i < n; i++)
  69.     if (!addseg())
  70.         break;
  71.  
  72.     /* return the number of segments added */
  73.     return (cvfixnum((FIXNUM)i));
  74. }
  75.  
  76. /* xalloc - xlisp function to set the number of nodes to allocate */
  77. NODE *xalloc(args)
  78.   NODE *args;
  79. {
  80.     int n,oldn;
  81.  
  82.     /* get the new number to allocate */
  83.     n = xlmatch(INT,&args)->n_int;
  84.  
  85.     /* make sure there aren't any more arguments */
  86.     xllastarg(args);
  87.  
  88.     /* set the new number of nodes to allocate */
  89.     oldn = anodes;
  90.     anodes = n;
  91.  
  92.     /* return the old number */
  93.     return (cvfixnum((FIXNUM)oldn));
  94. }
  95.  
  96. /* xmem - xlisp function to print memory statistics */
  97. NODE *xmem(args)
  98.   NODE *args;
  99. {
  100.     /* make sure there aren't any arguments */
  101.     xllastarg(args);
  102.  
  103.     /* print the statistics */
  104.     stats();
  105.  
  106.     /* return nil */
  107.     return (NIL);
  108. }
  109.  
  110. /* xtype - return type of a thing */
  111. NODE *xtype(args)
  112.     NODE *args;
  113. {
  114.     NODE *arg;
  115.  
  116.     if (!(arg = xlarg(&args)))
  117.     return (NIL);
  118.  
  119.     switch (ntype(arg)) {
  120.     case SUBR:    return (a_subr);
  121.     case FSUBR:    return (a_fsubr);
  122.     case LIST:    return (a_list);
  123.     case SYM:    return (a_sym);
  124.     case INT:    return (a_int);
  125.     case FLOAT:    return (a_float);
  126.     case STR:    return (a_str);
  127.     case OBJ:    return (a_obj);
  128.     case FPTR:    return (a_fptr);
  129.     default:    xlfail("bad node type");
  130.     }
  131. }
  132.  
  133. /* xbaktrace - print the trace back stack */
  134. NODE *xbaktrace(args)
  135.   NODE *args;
  136. {
  137.     int n;
  138.  
  139.     n = (args ? xlmatch(INT,&args)->n_int : -1);
  140.     xllastarg(args);
  141.     xlbaktrace(n);
  142.     return (NIL);
  143. }
  144.  
  145. /* xexit - get out of xlisp */
  146. NODE *xexit(args)
  147.   NODE *args;
  148. {
  149.     xllastarg(args);
  150.     exit();
  151. }
  152.